Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue31/bitview/BITVIEW.ZIP/BITVIEW.PAS

Pascal/Delphi Source File | 1998-01-30 | 15.3 KB | 512 lines

//=========================== *BIG* BITMAP VIEWER ==============================
//
// This component came about because I wanted to display 4000 x 4000 x 256 colour
// bitmaps (about 16MB in size).  Using a TBitmap and a TImage took ages to load
// the images as a whole load of disc-swap file activity took place.  The answer
// was to use a memory mapped file and the StretchDIBits API call which takes
// a memory pointer to the bitmap data, and doesn't realise (of course) that
// it's a memory mapped file.  Load times and resource used drastically reduced.
//
// This component was written to display the UK Ordanance Survey's 1:50000 scale
// Landranger maps bought as bitmaps.  If anyone wants some additional code
// associated with displaying these maps then contact me at the email below.
//
// This version has been used and tested on 2, 16 and 256 colour bitmaps.  I
// believe it should work on the higher resolution bitmaps as well, but it
// is untested.
//
// The component is a desendant of TGraphicControl (just like a TPaintBox). I
// used the TGraphicControl rather than a TPaintBox to have control of the
// parent properties I wanted to publish.
//
// Version 1.00
// Grahame Marsh 19 January 1997
//
// Freeware - you get it for free, I take nothing, I make no promises!
//
// Please feel free to contact me: [e-mail]
//
// Revison History:
//    Version 1.00 - initial release  19-1-97
//            1.01 - improved colour rendering under NT 4 using SetStretchBltMode
//                   changed name GetPalette to GetBitmapPalette

unit
  BitView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DsgnIntf;

type
  TBMPFilename = type string; // filename will have its owner property editor
                              // Is this use for "type" documented anywhere?
type
  TBigBitmapViewer = class (TGraphicControl)
  private
    FFileName: TBMPFilename;  // bitmap filename, own type so it can have own prop editor
    FPalette : HPalette;      // handle to bitmap palette
    FData    : pointer;       // pointer to start of data in memory mapped file
    FBitmapWidth,             // copy of bitmap width info for convience
    FBitmapHeight,            // copy of bitmap height info for convience
    FColours : integer;       // number of colours in palette
    FCentre,                  // centre the bitmap in the control
    FStretch,                 // stretch the bitmap to fill the control
    FAutoSize,                // automatically size the control to display the bitmap
    FActive  : boolean;       // true opens the viewer, false it's closed
    FFileHeader : PBitmapFileHeader;  // pointer to TBitmapFileHeader record
    FInfoHeader : PBitmapInfoHeader;  // pointer to TBitmapInfoHeader record
    FInfo : PBitmapInfo;      // pointer to the TBitmapInfo record
    FPixelStart : pointer;    // pointer to the start of the pixel data
    procedure SetActive (Value : boolean);
    procedure SetAutoSize (Value : boolean);
    procedure SetFilename (const Value : TBMPFilename);
    procedure SetStretch (Value : boolean);
    procedure SetCentre (Value : boolean);
    procedure SetDummyInt (Value : integer);
  protected
    procedure OpenViewer; virtual;
    procedure CloseViewer; virtual;
    procedure GetBitmapPalette; virtual;
    procedure Paint; override; // virtual
    procedure Changes; virtual;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
// open the viewer
    procedure Close;
// close the viewer
    procedure Open;
// pointer to the file header info
    property BitmapFileHeader : PBitmapFileHeader read FFileHeader;
// pointer to the bitmap info header
    property BitmapInfoHeader : PBitmapInfoHeader read FInfoHeader;
// pointer to the bitmap info
    property BitmapInfo : PBitmapInfo read FInfo;
// pointer to the bitmap pixel data array
    property PixelStart : pointer read FPixelStart;
// palette handle
    property Palette : HPalette read FPalette;
  published
//READ-WRITE PROPS
// size control to bitmap
    property AutoSize : boolean read FAutoSize write SetAutoSize default false;
// bitmap centred
    property Centre : boolean read FCentre write SetCentre default false;
// filename of bitmap
    property Filename : TBMPFilename read FFilename write SetFilename;
// stretch bitmap
    property Stretch : boolean read FStretch write SetStretch default false;
// READ-ONLY PROPS
// number of colours in the bitmap palette
    property Colours : integer read FColours write SetDummyInt stored false;
// bitmap width
    property BitmapHeight : integer read FBitmapHeight write SetDummyInt stored false;
// bitmap height
    property BitmapWidth : integer read FBitmapWidth write SetDummyInt stored false;
// TGraphicControl PROPS NOW PUBLISHED
    property Align;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
// viewer activate - stream active last!
    property Active : boolean read FActive write SetActive default false;
  end;

procedure Register;

implementation

const
  BitmapSignature = $4D42;

procedure InvalidBitmap;
begin
  raise Exception.Create ('Bitmap image is not valid')
end;

procedure NotWhenActive;
begin
  raise Exception.Create ('Not on an active big bitmap viewer')
end;

constructor TBigBitmapViewer.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  Width := 150;
  Height := 150
end;

destructor TBigBitmapViewer.Destroy;
begin
  CloseViewer;  // ensure file view is freed
  inherited Destroy
end;

// This procedure takes the palette out of the bitmap.  It references two
// values to do this (FColours - the colour count, and FInfo a pointer to
// TBitmapInfo record).  This is a fairly standard way of getting a palette.
// If successful, FPalette contains a handle to a copy of the palette.
procedure TBigBitmapViewer.GetBitmapPalette;
var
  SysPalSize,
  Loop,
  LogSize : integer;
  LogPalette : PLogPalette;
  DC : HDC;
  Focus : HWND;
begin
  FPalette := 0;

// fetch palette for colour bitmaps only
  if FColours > 2 then
  begin

// create palette from bitmap info
    LogSize := SizeOf (TLogPalette) + pred(FColours) * SizeOf(TPaletteEntry);
    LogPalette := AllocMem (LogSize);
    try
      with LogPalette^ do
      begin
        palNumEntries := FColours;
        palVersion := $0300;

// I prefer to test programs with $R+, but this section of the program
// must be compiled with $R-.  This $IFOPT enables the restoration of
// $R+ condition later on, but only if set now.
{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$R-}
{$ENDIF}
        Focus := GetFocus;
        DC := GetDC (Focus);
        try
          SysPalSize := GetDeviceCaps (DC, SIZEPALETTE);
          if (FColours = 16) and (SysPalSize >= 16) then
          begin
            GetSystemPaletteEntries (DC, 0, 8, palPalEntry);
            loop := 8;
            GetSystemPaletteEntries (DC, SysPalSize - loop, loop, palPalEntry[loop])
          end else
            with FInfo^ do
              for loop := 0 to pred (FColours) do
              begin
                palPalEntry[loop].peRed   := bmiColors[loop].rgbRed;
                palPalEntry[loop].peGreen := bmiColors[loop].rgbGreen;
                palPalEntry[loop].peBlue  := bmiColors[loop].rgbBlue
              end
        finally
          ReleaseDC(Focus, DC)
        end
{$IFDEF R_PLUS}
  {$R+}
  {$UNDEF R_PLUS}
{$ENDIF}
      end;
      FPalette := CreatePalette (LogPalette^)
    finally
      FreeMem (LogPalette, LogSize)
    end
  end
end;

// Open the file for viewing, here is the memory mapped file stuff.  It
// is a simple use of memory mapped files as I only need to open the file
// with read permissions.  The following steps are taken.
// 1. Get a read only file handle to the bitmap file
// 2. Get a file mapping using that handle
// 3. Get a view of the file from that handle
// 4. Set up some useful pointers to often used bits of the view
// 5. Get the palette (if present) from the view

procedure TBigBitmapViewer.OpenViewer;
var
  FileHandle,
  MapHandle : THandle;
begin
  if FActive then
    exit;

// open file
  FileHandle := FileOpen (FFilename, fmOpenRead + fmShareDenyNone);
  if FileHandle = INVALID_HANDLE_VALUE then
    raise Exception.Create ('Failed to open ' + FFilename);

// create file map and throw away the file handle
  try
    MapHandle := CreateFileMapping (FileHandle, nil, PAGE_READONLY, 0, 0, nil);
    if MapHandle = 0 then
      raise Exception.Create ('Failed to map file')
  finally
    CloseHandle (FileHandle)
  end;

// view file map and throw away the map handle
  try
    FData := MapViewOfFile (MapHandle, FILE_MAP_READ, 0, 0, 0);
    if FData = nil then
      raise Exception.Create ('Failed to view map file')
  finally
    CloseHandle (MapHandle)
  end;

// set pointers into file view
  FFileHeader := FData;

// test for valid bitmap file:
  if FFileHeader^.bfType <> BitmapSignature then
  begin
    UnmapViewOfFile (FData);
    FData := nil;
    InvalidBitmap
  end;

// set up a few other pointers into the data for records we will
// need to reference in the file, it's easiest just to do it this once.
  FInfoHeader := pointer (integer (FData) + sizeof (TBitmapFileHeader));
  FInfo := pointer (FInfoHeader);
  FPixelStart := pointer (integer(FData) + FFileHeader^.bfOffBits);

// get number of colours, above 256 colour files have FColours=0
  with FInfoHeader^ do
    if biClrUsed <> 0 then
      FColours := biClrUsed
    else
      case biBitCount of
        1,
        4,
        8 : FColours := 1 shl biBitCount
      else
        FColours := 0
      end;

  // get bitmap size into easy to access properties
  FBitmapHeight := FInfoHeader^.biHeight;
  FBitmapWidth := FInfoHeader^.biWidth;

// fetch the palette
  GetBitmapPalette;

// other setups
  FActive := true;
  Changes
end;

// The viewer PAINT method.
//            -----
// The actions carried out here are:
// 1. If in design mode and not active put up a simple rectangle
// 2. Select and realize the bitmap palette
// 3. Calculate the bitmap image location taking into account the stretch
//    and centre properties
// 4. Squirt the bitmap onto the canvas
// 5. Select the orginal palette

procedure TBigBitmapViewer.Paint;
var
  OldMode    : integer;
  OldPalette : HPalette;
  Dest       : TRect;
begin
  with Canvas do
// simple rectangle for design mode
    if (csDesigning in ComponentState) and not FActive then
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle (0, 0, Width, Height)
    end else begin
// select the bitmap palette
      if FPalette <> 0 then
        OldPalette := SelectPalette (Handle, FPalette, false)
      else
        OldPalette := 0;

      try
        RealizePalette (Handle);
// calculate the bitmap location
        if FStretch then
          Dest := ClientRect
        else
          if Centre then
            Dest := Rect ((Width - FBitmapWidth) div 2, (Height - FBitmapHeight) div 2,
                            FBitmapWidth, FBitmapHeight)
          else
            Dest := Rect (0, 0, FBitmapWidth, FBitmapHeight);

// set blt mode according to number of colours
        if FColours = 2 then
          OldMode := SetStretchBltMode (Handle, BLACKONWHITE)
        else
          OldMode := SetStretchBltMode (Handle, COLORONCOLOR);
        try
// display it
          with Dest do
            StretchDIBits (Handle,
                           Left, Top, Right, Bottom,
                           0, 0, FBitmapWidth, FBitmapHeight,
                           FPixelStart, FInfo^,
                           DIB_RGB_COLORS, SRCCOPY)
        finally
          SetStretchBltMode (Handle, OldMode)
        end
      finally
// put the old palette back in
        if OldPalette <> 0 then
          SelectPalette (Handle, OldPalette, false)
      end
    end
end;

// close the viewer by unmapping the file, setting the view to nil and
// discarding the palette
procedure TBigBitmapViewer.CloseViewer;
begin
  if FActive then
  begin
    FActive := false;
    if FData <> nil then
    begin
      UnmapViewOfFile (FData);  //  remove the memory mapped file view
      FData := nil
    end;
    if FPalette <> 0 then
      DeleteObject (FPalette)   // free the palette
  end
end;

// set active to true
procedure TBigBitmapViewer.Open;
begin
  Active := true
end;

// set active to false
procedure TBigBitmapViewer.Close;
begin
  Active := false
end;

// Property Methods:

procedure TBigBitmapViewer.SetActive (Value : boolean);
begin
  if Value <> FActive then
    if Value then
      OpenViewer
    else
      CloseViewer
end;

procedure TBigBitmapViewer.SetAutoSize (Value : boolean);
begin
  if Value <> FAutoSize then
  begin
    FAutoSize := Value;
    Changes
  end
end;

procedure TBigBitmapViewer.SetStretch (Value : boolean);
begin
  if Value <> FStretch then
  begin
    FStretch := Value;
    Changes
  end
end;

procedure TBigBitmapViewer.SetCentre (Value : boolean);
begin
  if Value <> FCentre then
  begin
    FCentre := Value;
    Changes
  end
end;

procedure TBigBitmapViewer.SetFilename (const Value : TBMPFilename);
begin
  if Value <> FFilename then
  begin
    if FActive then
      NotWhenActive;
    FFilename := Value
  end
end;

// This dummy set integer procedure is used with the BitmapHeight and
// BitmapWidth properties to make them appear in the object inspector
// WITHOUT allowing them to be edited - ie readonly.
procedure TBigBitmapViewer.SetDummyInt (Value : integer);
begin
end;

// Process changes to the TGraphicControl depending on size of
// the image compared to the form.
procedure TBigBitmapViewer.Changes;
begin
  if (BitmapWidth >= Width) and (BitmapHeight >= Height) then
    ControlStyle := ControlStyle + [csOpaque]
  else
    ControlStyle := ControlStyle - [csOpaque];

  if AutoSize and (BitmapWidth > 0) and (BitmapHeight > 0) then
    SetBounds (Left, Top, BitmapWidth, BitmapHeight)
  else
    Invalidate
end;

// filename property editor .. fileopen dialog box
type
  TBMPFilenameProperty = class (TStringProperty)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

procedure TBMPFilenameProperty.Edit;
begin
  with TOpenDialog.Create(Application) do
  begin
    Filename := GetValue;
    Filter := 'Windows bitmaps (*.BMP)|*.BMP';
    Options := Options + [ofPathMustExist, ofFileMustExist, ofHideReadOnly];
    try
      if Execute then
        SetValue(Filename)
    finally
      Free
    end
  end
end;

function TBMPFilenameProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paRevertable]
end;

procedure Register;
begin
  RegisterComponents ('My Controls', [TBigBitmapViewer]);
  RegisterPropertyEditor (TypeInfo (TBMPFilename), nil, '', TBMPFilenameProperty);
end;

end.